home *** CD-ROM | disk | FTP | other *** search
/ Delphi Informant Complete 1995 - 2000 / Delphi Informant Complete 1995 to 2000.iso / Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar / 1998 / Feb / di9802kw / ListPics1.pas < prev    next >
Pascal/Delphi Source File  |  1997-08-19  |  4KB  |  111 lines
  1. unit ListPics1;
  2.  
  3. {
  4.   Demonstration of WebPics CGI program.
  5.  
  6.   Written by Keith Wood, 12 Aug 1997.
  7. }
  8.  
  9. interface
  10.  
  11. uses
  12.   Windows, Messages, SysUtils, Classes, HTTPApp, Db, DBWeb, DBTables;
  13.  
  14. type
  15.   TwmdListPics = class(TWebModule)
  16.     qryListPics: TQuery;
  17.     wtpListPics: TDataSetTableProducer;
  18.     qryListPicsPICTURE_NO: TIntegerField;
  19.     qryListPicsPICTURE_TEXT: TStringField;
  20.     wppOnePic: TPageProducer;
  21.     qryListPicsPICTURE_TYPE: TStringField;
  22.     wppNotFound: TPageProducer;
  23.     procedure wmdListPicswacListPicsAction(Sender: TObject;
  24.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  25.     procedure wtpListPicsFormatCell(Sender: TObject; CellRow,
  26.       CellColumn: Integer; var BgColor: THTMLBgColor;
  27.       var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
  28.       CellData: String);
  29.     procedure wmdListPicswacOnePicAction(Sender: TObject;
  30.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  31.     procedure wppOnePicHTMLTag(Sender: TObject; Tag: TTag;
  32.       const TagString: String; TagParams: TStrings;
  33.       var ReplaceText: String);
  34.     procedure wppNotFoundHTMLTag(Sender: TObject; Tag: TTag;
  35.       const TagString: String; TagParams: TStrings;
  36.       var ReplaceText: String);
  37.   private
  38.     { Private declarations }
  39.   public
  40.     { Public declarations }
  41.   end;
  42.  
  43. const
  44.   sYN: array [boolean] of string = ('N', 'Y');
  45. var
  46.   wmdListPics: TwmdListPics;
  47.  
  48. implementation
  49.  
  50. {$R *.DFM}
  51.  
  52. { Picture list --------------------------------------------------------------- }
  53.  
  54. { Generate list of pictures in the database }
  55. procedure TwmdListPics.wmdListPicswacListPicsAction(Sender: TObject;
  56.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  57. begin
  58.   Response.Content := wtpListPics.Content;
  59. end;
  60.  
  61. { Format each description as a link to the picture }
  62. procedure TwmdListPics.wtpListPicsFormatCell(Sender: TObject; CellRow,
  63.   CellColumn: Integer; var BgColor: THTMLBgColor; var Align: THTMLAlign;
  64.   var VAlign: THTMLVAlign; var CustomAttrs, CellData: String);
  65. begin
  66.   if (CellColumn = 0) and (CellRow <> 0) then
  67.     CellData := '<a href="/cgi-bin/listpics.exe/single?id=' +
  68.       qryListPics.FieldByName('PICTURE_NO').AsString + '">' + CellData + '</a>';
  69. end;
  70.  
  71. { Single picture ------------------------------------------------------------- }
  72.  
  73. { Generate a single picture page }
  74. procedure TwmdListPics.wmdListPicswacOnePicAction(Sender: TObject;
  75.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  76. begin
  77.   if qryListPics.Locate('PICTURE_NO', Request.QueryFields.Values['ID'], []) then
  78.     Response.Content := wppOnePic.Content
  79.   else
  80.     Response.Content := wppNotFound.Content;
  81. end;
  82.  
  83. { Substitute database values into the page }
  84. procedure TwmdListPics.wppOnePicHTMLTag(Sender: TObject; Tag: TTag;
  85.   const TagString: String; TagParams: TStrings; var ReplaceText: String);
  86. begin
  87.   with qryListPics do
  88.     if TagString = 'TEXT' then
  89.       ReplaceText := FieldByName('PICTURE_TEXT').AsString
  90.     else if TagString = 'TYPE' then
  91.       ReplaceText := FieldByName('PICTURE_TYPE').AsString
  92.     else if TagString = 'ID' then
  93.       ReplaceText := FieldByName('PICTURE_NO').AsString
  94.     else if TagString = 'SCRIPT' then
  95.       ReplaceText := Request.ScriptName;
  96. end;
  97.  
  98. { Supply error message with incorrect parameters }
  99. procedure TwmdListPics.wppNotFoundHTMLTag(Sender: TObject; Tag: TTag;
  100.   const TagString: String; TagParams: TStrings; var ReplaceText: String);
  101. begin
  102.   if TagString = 'SCHEME' then
  103.     ReplaceText := Request.QueryFields.Values['SCHEME']
  104.   else if TagString = 'ID' then
  105.     ReplaceText := Request.QueryFields.Values['ID']
  106.   else if TagString = 'SCRIPT' then
  107.     ReplaceText := Request.ScriptName;
  108. end;
  109.  
  110. end.
  111.